From 9e2022652258e8a30e5cedbf0abc9cd85a0f6af7 Mon Sep 17 00:00:00 2001
From: Peter Bex <peter.bex@xs4all.nl>
Date: Thu, 18 Apr 2013 00:31:08 +0200
Subject: [PATCH] Implement file-select in terms of POSIX poll() for UNIX

Signed-off-by: felix <felix@call-with-current-continuation.org>
---
 posixunix.scm |  116 ++++++++++++++++++++++++++------------------------------
 1 files changed, 54 insertions(+), 62 deletions(-)

diff --git a/posixunix.scm b/posixunix.scm
index 15cb535..90e0176 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -67,6 +67,7 @@ static C_TLS int C_wait_status;
 #endif
 
 #include <sys/mman.h>
+#include <sys/poll.h>
 #include <time.h>
 
 #ifndef O_FSYNC
@@ -136,7 +137,6 @@ static C_TLS struct {
 static C_TLS int C_pipefds[ 2 ];
 static C_TLS time_t C_secs;
 static C_TLS struct tm C_tm;
-static C_TLS fd_set C_fd_sets[ 2 ];
 static C_TLS struct timeval C_timeval;
 static C_TLS char C_hostbuf[ 256 ];
 static C_TLS struct stat C_statbuf;
@@ -303,13 +303,6 @@ static C_TLS sigset_t C_sigset;
 #define C_fseek(p, n, w)    C_mk_nbool(fseek(C_port_file(p), C_num_to_int(n), C_unfix(w)))
 #define C_lseek(fd, o, w)     C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w)))
 
-#define C_zero_fd_set(i)      FD_ZERO(&C_fd_sets[ i ])
-#define C_set_fd_set(i, fd)   FD_SET(fd, &C_fd_sets[ i ])
-#define C_test_fd_set(i, fd)  FD_ISSET(fd, &C_fd_sets[ i ])
-#define C_C_select(m)         C_fix(select(C_unfix(m), &C_fd_sets[ 0 ], &C_fd_sets[ 1 ], NULL, NULL))
-#define C_C_select_t(m, t)    (C_set_timeval(t, &C_timeval), \
-			       C_fix(select(C_unfix(m), &C_fd_sets[ 0 ], &C_fd_sets[ 1 ], NULL, &C_timeval)))
-
 #define C_ctime(n)          (C_secs = (n), ctime(&C_secs))
 
 #if defined(__SVR4) || defined(C_MACOSX)
@@ -656,60 +649,59 @@ EOF
 
 ;;; I/O multiplexing:
 
-(define file-select
-  (let ([fd_zero (foreign-lambda void "C_zero_fd_set" int)]
-        [fd_set (foreign-lambda void "C_set_fd_set" int int)]
-        [fd_test (foreign-lambda bool "C_test_fd_set" int int)] )
-    (lambda (fdsr fdsw . timeout)
-      (let ([fdmax 0]
-            [tm (if (pair? timeout) (car timeout) #f)] )
-        (fd_zero 0)
-        (fd_zero 1)
-        (cond [(not fdsr)]
-              [(fixnum? fdsr)
-               (set! fdmax fdsr)
-               (fd_set 0 fdsr) ]
-              [else
-               (##sys#check-list fdsr 'file-select)
-               (for-each
-                (lambda (fd)
-                  (##sys#check-exact fd 'file-select)
-                  (set! fdmax (##core#inline "C_i_fixnum_max" fdmax fd))
-                  (fd_set 0 fd) )
-                fdsr) ] )
-        (cond [(not fdsw)]
-              [(fixnum? fdsw)
-               (set! fdmax fdsw)
-               (fd_set 1 fdsw) ]
-              [else
-               (##sys#check-list fdsw 'file-select)
-               (for-each
-                (lambda (fd)
-                  (##sys#check-exact fd 'file-select)
-                  (set! fdmax (##core#inline "C_i_fixnum_max" fdmax fd))
-                  (fd_set 1 fd) )
-                fdsw) ] )
-        (let ([n (cond [tm
-                        (##sys#check-number tm 'file-select)
-                        (##core#inline "C_C_select_t" (fx+ fdmax 1) tm) ]
-                       [else (##core#inline "C_C_select" (fx+ fdmax 1))] ) ] )
-          (cond [(fx< n 0)
-                 (posix-error #:file-error 'file-select "failed" fdsr fdsw) ]
-                [(fx= n 0) (values (if (pair? fdsr) '() #f) (if (pair? fdsw) '() #f))]
-                [else
-                 (values
-                  (and fdsr
-                       (if (fixnum? fdsr)
-                           (fd_test 0 fdsr)
-                           (let ([lstr '()])
-                             (for-each (lambda (fd) (when (fd_test 0 fd) (set! lstr (cons fd lstr)))) fdsr)
-                             lstr) ) )
-                  (and fdsw
-                       (if (fixnum? fdsw)
-                           (fd_test 1 fdsw)
-                           (let ([lstw '()])
-                             (for-each (lambda (fd) (when (fd_test 1 fd) (set! lstw (cons fd lstw)))) fdsw)
-                             lstw) ) ) ) ] ) ) ) ) ) )
+(define (file-select fdsr fdsw . timeout)
+  (let* ((tm (if (pair? timeout) (car timeout) #f))
+	 (fdsrl (cond ((not fdsr) '())
+		      ((fixnum? fdsr) (list fdsr))
+		      (else (##sys#check-list fdsr 'file-select)
+			    fdsr)))
+	 (fdswl (cond ((not fdsw) '())
+		      ((fixnum? fdsw) (list fdsw))
+		      (else (##sys#check-list fdsw 'file-select)
+			    fdsw)))
+	 (nfdsr (##sys#length fdsrl))
+	 (nfdsw (##sys#length fdswl))
+	 (nfds (fx+ nfdsr nfdsw))
+	 (fds-blob (##sys#make-blob
+		    (fx* nfds (foreign-value "sizeof(struct pollfd)" int)))))
+    (when tm (##sys#check-number tm))
+    (do ((i 0 (fx+ i 1))
+	 (fdsrl fdsrl (cdr fdsrl)))
+	((null? fdsrl))
+      ((foreign-lambda* void ((int i) (int fd) (scheme-pointer p))
+	 "struct pollfd *fds = p;"
+	 "fds[i].fd = fd; fds[i].events = POLLIN;") i (car fdsrl) fds-blob))
+    (do ((i nfdsr (fx+ i 1))
+	 (fdswl fdswl (cdr fdswl)))
+	((null? fdswl))
+      ((foreign-lambda* void ((int i) (int fd) (scheme-pointer p))
+	 "struct pollfd *fds = p;"
+	 "fds[i].fd = fd; fds[i].events = POLLOUT;") i (car fdswl) fds-blob))
+    (let ((n ((foreign-lambda int "poll" scheme-pointer int int)
+	      fds-blob nfds (if tm (inexact->exact (* (max 0 tm) 1000)) -1))))
+      (cond ((fx< n 0)
+	     (posix-error #:file-error 'file-select "failed" fdsr fdsw) )
+	    ((fx= n 0) (values (if (pair? fdsr) '() #f) (if (pair? fdsw) '() #f)))
+	    (else
+	     (let ((rl (let lp ((i 0) (res '()) (fds fdsrl))
+			 (cond ((null? fds) (##sys#fast-reverse res))
+			       (((foreign-lambda* bool ((int i) (scheme-pointer p))
+				   "struct pollfd *fds = p;"
+				   "C_return(fds[i].revents & (POLLIN|POLLERR|POLLHUP|POLLNVAL));")
+				 i fds-blob)
+				(lp (fx+ i 1) (cons (car fds) res) (cdr fds)))
+			       (else (lp (fx+ i 1) res (cdr fds))))))
+		   (wl (let lp ((i nfdsr) (res '()) (fds fdswl))
+			 (cond ((null? fds) (##sys#fast-reverse res))
+			       (((foreign-lambda* bool ((int i) (scheme-pointer p))
+				   "struct pollfd *fds = p;"
+				   "C_return(fds[i].revents & (POLLOUT|POLLERR|POLLHUP|POLLNVAL));")
+				 i fds-blob)
+				(lp (fx+ i 1) (cons (car fds) res) (cdr fds)))
+			       (else (lp (fx+ i 1) res (cdr fds)))))))
+	       (values
+		(and fdsr (if (fixnum? fdsr) (and (memq fdsr rl) fdsr) rl))
+		(and fdsw (if (fixnum? fdsw) (and (memq fdsw wl) fdsw) wl)))))))))
 
 
 ;;; File attribute access:
-- 
1.7.2.1

